home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / junk.em < prev    next >
Lisp/Scheme  |  1993-02-02  |  3KB  |  120 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: junk.em
  4. ;; Date: Sat Feb 22 19:58:46 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule junk
  11.   (standard0
  12.    list-fns
  13.    
  14.    ;;   instruct
  15.    streams
  16.    )
  17.   ()
  18.   
  19.   (defstruct state ()
  20.     ((stream initarg stream
  21.            reader state-stream)
  22.      (vars initarg vars 
  23.        reader state-vars))
  24.     constructor (new-state loc vars))
  25.  
  26.   (defconstant peep-rules
  27.     '(one-of (instruct 
  28.           slide (d1 keep1)
  29.           (next 
  30.            (one-of (instruct 
  31.             slide (d2 k2)
  32.             (test ((not (> keep1 k2)))
  33.                   (output (slide (+ d1 d2 (- keep1)) k2)))))))
  34.          (instruct 
  35.           nth (n)
  36.           (next
  37.            (one-of (instruct slide (d1 k1)
  38.                  (one-of (test ((> n d1))
  39.                            (output (slide (- d1 1) (- k1 1))
  40.                                (nth (+ n (- d1) k1))))
  41.                      (test ((< n k1))
  42.                            (output (slide (- d1 1) (- k1 1))
  43.                                (nth n)))
  44.                      (test ((= k1 2) (= n 1))
  45.                            (output (slide (- d1 1) 2) (swap))))))))
  46.          (instruct swap ()
  47.                (next 
  48.             (instruct swap ()
  49.                   (output))))
  50.          ;; rats... can't do anything.
  51.          ))
  52.  
  53.  
  54.   (defun match-instruct (name i)
  55.     (eq name (car i)))
  56.  
  57.   (defun preprocess-instruct (args)
  58.     `(if (not (match-instruct ',(car args) i))
  59.      nil
  60.        (let ,(make-bindings (cadr args))
  61.      ,(preprocess-rules (caddr args)))))
  62.  
  63.   (defun make-bindings (lst)
  64.     (labels ((binder (names n)
  65.              (if (null names) nil
  66.                (cons (list (car names) `(nth ,n (cdr i)))
  67.                  (binder (cdr names) (+ n 1))))))
  68.         (binder lst 0)))
  69.  
  70.   (defun preprocess-test (args)
  71.     `(if ,(preprocess-test-conditions (car args))
  72.      ,(preprocess-rules (cadr args))
  73.        nil))
  74.   
  75.   (defun preprocess-test-conditions (tests)
  76.     (cons 'and tests))
  77.               
  78.   (defun preprocess-next (args)
  79.     `(list 'incomplete 
  80.        (lambda (i) 
  81.          ,(preprocess-rules (car args)))))
  82.  
  83.   (defun preprocess-one-of (args)
  84.     (fold (lambda (preproc lst)
  85.         `(append ,preproc ,lst))
  86.       (mapcar (lambda (x) 
  87.             (preprocess-rules x))
  88.           args)
  89.       nil))
  90.  
  91.   (defun preprocess-output (args)
  92.     `(cons 'complete ,(mapcar 
  93.                (lambda (text) 
  94.              `(cons ,(car text) 
  95.                 (list ,(cdr text))))
  96.                args)))
  97.  
  98.   (defconstant find-preproc (mk-finder))
  99.   (progn ((setter find-preproc) 'output  preprocess-output)
  100.      ((setter find-preproc) 'next  preprocess-next)
  101.      ((setter find-preproc) 'instruct  preprocess-instruct)  
  102.      ((setter find-preproc) 'test  preprocess-test)
  103.      ((setter find-preproc) 'one-of  preprocess-one-of))
  104.  
  105.   (defun preprocess-rules (rule)
  106.     ((find-preproc (car rule)) (cdr rule)))
  107.   
  108.   (defmacro peephole-matcher (x)
  109.     `(lambda (i)
  110.        ,(preprocess-rules  x)))
  111.   ;; end module
  112.   )
  113. nth
  114. static
  115. pop
  116. set
  117.  
  118.  
  119.  
  120.